VERSION 5.00
Begin VB.UserControl TabHeader 
   Alignable       =   -1  'True
   CanGetFocus     =   0   'False
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   ScaleHeight     =   240
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   320
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   10
      Left            =   120
      Top             =   2160
   End
   Begin VB.Image i2 
      Height          =   360
      Left            =   2400
      Picture         =   "TabHeader.ctx":0000
      Top             =   1080
      Visible         =   0   'False
      Width           =   240
   End
   Begin VB.Image i1 
      Height          =   765
      Left            =   1560
      Picture         =   "TabHeader.ctx":04C2
      Top             =   1080
      Visible         =   0   'False
      Width           =   780
   End
End
Attribute VB_Name = "TabHeader"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function FrameRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Type POINTAPI
        X As Long
        Y As Long
End Type

Private bm As New cAlphaDibSection
Private bm1 As New cAlphaDibSection
Private bm2 As New cAlphaDibSection

Private Type Type1
 Cap As String
End Type

Private strs() As Type1
Private strc As Long
Private strn As Long

Private nx As Long, mx As Long, pw As Long
Private hb As Boolean, ts As Long, ps As Long, ps2 As Long, ps3 As Long

Private ac As Boolean, ax As Long, vx As Long, ms As Boolean
Private fnt As New StdFont

Event PanelClick(ByVal Index As Long)

Private Sub Timer1_Timer()
Dim p As POINTAPI
If ax <> 0 Then
 If ac Then
  vx = vx + ax
 Else
  vx = vx - ax
 End If
 If vx = 0 Then
  ax = 0
 End If
 nx = nx + vx
 If nx < 0 Then
  nx = 0
  vx = 0
  ax = 0
 ElseIf nx > strc * pw - UserControl.ScaleWidth + 16 + ps2 + ps3 Then
  nx = strc * pw - UserControl.ScaleWidth + 16 + ps2 + ps3
  vx = 0
  ax = 0
 End If
 Redraw
End If
If ms Then
 GetCursorPos p
 ScreenToClient UserControl.hwnd, p
 If p.X < 0 Or p.X > UserControl.ScaleWidth Or p.Y < 0 Or p.Y > UserControl.ScaleHeight Then
  ms = False
  ac = False
  mx = -1
  Redraw
 End If
End If
End Sub

Private Sub UserControl_Initialize()
On Error Resume Next
bm1.CreateFromPicture i1.Picture
bm2.CreateFromPicture i2.Picture
fnt.Name = "Tahoma"
MsgBox Ambient.UserMode
UserControl_Resize
End Sub

Private Sub UserControl_InitProperties()
pw = 64
ts = 2
ps = 1
ps2 = 2
ps3 = 2
With fnt
 .Name = "Tahoma"
 .Size = 8
End With
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If X < 8 Then
ElseIf X > UserControl.ScaleWidth - 8 Then
ElseIf mx > 0 And mx <= strc Then
 strn = mx
 Redraw
 RaiseEvent PanelClick(strn)
End If
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Long
i = Int((X + nx - 8 - ps3) / pw) + 1
If i <> mx Then
 mx = i
 Redraw
End If
If strc * pw > UserControl.ScaleWidth - 16 Then
 If X < 8 And nx > 0 Then
  ac = True
  ax = -1
 ElseIf X > UserControl.ScaleWidth - 8 And nx < strc * pw - UserControl.ScaleWidth + 16 + ps2 + ps3 Then
  ac = True
  ax = 1
 Else
  ac = False
 End If
End If
ms = True
End Sub

Private Sub UserControl_Paint()
bm.PaintPicture UserControl.hdc
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
With PropBag
 pw = PropBag.ReadProperty("PanelWidth", 64)
 hb = PropBag.ReadProperty("HighlightBold", False)
 ts = PropBag.ReadProperty("PanelTopSpace", 2)
 ps = PropBag.ReadProperty("PanelSpace", 1)
 ps2 = PropBag.ReadProperty("PanelOverlapRight", 2)
 ps3 = PropBag.ReadProperty("PanelOverlapLeft", 2)
 fnt.Size = PropBag.ReadProperty("FontSize", 8)
End With
End Sub

Private Sub UserControl_Resize()
bm.Create UserControl.ScaleWidth, UserControl.ScaleHeight
Redraw
UserControl_Paint
End Sub

Private Sub DrawPanel(ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal w As Long, ByVal h As Long, ByVal s As String, ByVal Style As Long)
bm1.PaintPicture hdc, X, Y, 4, 4, 0, Style * 17
StretchBlt hdc, X + 4, Y, w - 8, 4, bm1.hdc, 4, Style * 17, 44, 4, vbSrcCopy
bm1.PaintPicture hdc, X + w - 4, Y, 4, 4, 48, Style * 17
StretchBlt hdc, X, Y + 4, 4, h - 4, bm1.hdc, 0, Style * 17 + 4, 4, 13, vbSrcCopy
StretchBlt hdc, X + 4, Y + 4, w - 8, h - 4, bm1.hdc, 4, Style * 17 + 4, 44, 13, vbSrcCopy
StretchBlt hdc, X + w - 4, Y + 4, 4, h - 4, bm1.hdc, 48, Style * 17 + 4, 4, 13, vbSrcCopy
DrawTextB hdc, s, fnt, X + 8, Y, w - 16, h, DT_VCENTER Or DT_SINGLELINE, vbBlack, , True
End Sub

Public Sub Add(ByVal Caption As String)
strc = strc + 1
ReDim Preserve strs(1 To strc)
With strs(strc)
 .Cap = Caption
End With
Timer1.Enabled = True
Redraw
End Sub

Public Sub Clear()
Erase strs
strc = 0
Timer1.Enabled = False
Redraw
End Sub

Private Sub Redraw()
On Error Resume Next
Dim i As Long, h As Long, r As RECT
Dim X As Long, Y As Long, j As Long, k As Long
h = CreateSolidBrush(&HD8E9EC)
r.Right = bm.Width
r.Bottom = bm.Height
FillRect bm.hdc, r, h
For i = strc To 1 Step -1
 X = 8 + ps3 - nx + (i - 1) * pw
 If i = strn Then
  k = 2
  Y = 0
  fnt.Bold = hb
 Else
  Y = ts
  k = IIf(i = mx, 1, 0)
  fnt.Bold = False
 End If
 DrawPanel bm.hdc, X - (k \ 2) * ps3, Y, _
 pw - ((3 - k) \ 2) * ps + (k \ 2) * (ps2 + ps3), _
 bm.Height - Y, strs(i).Cap, k
Next i
r.Left = bm.Width - 8
FillRect bm.hdc, r, h
r.Left = 0
r.Right = 8
FillRect bm.hdc, r, h
If nx > 0 Then
 If ac And ax = -1 Then
  bm2.PaintPicture bm.hdc, 0, 0, 8, 4, 8, 0
  StretchBlt bm.hdc, 0, 4, 8, bm.Height - 8, bm2.hdc, 8, 4, 8, 8, vbSrcCopy
  bm2.PaintPicture bm.hdc, 0, bm.Height - 4, 8, 4, 8, 12
  TransBltA bm.hdc, 2, bm.Height \ 2 - 4, 4, 8, bm2.hdc, 0, 8, 4, 8, vbMagenta
 Else
  TransBltA bm.hdc, 2, bm.Height \ 2 - 4, 4, 8, bm2.hdc, 0, 0, 4, 8, vbMagenta
 End If
Else
 TransBltA bm.hdc, 2, bm.Height \ 2 - 4, 4, 8, bm2.hdc, 0, 16, 4, 8, vbMagenta
End If
If nx < strc * pw - UserControl.ScaleWidth + 16 + ps2 + ps3 Then
 If ac And ax = 1 Then
  bm2.PaintPicture bm.hdc, bm.Width - 8, 0, 8, 4, 8, 0
  StretchBlt bm.hdc, bm.Width - 8, 4, 8, bm.Height - 8, bm2.hdc, 8, 4, 8, 8, vbSrcCopy
  bm2.PaintPicture bm.hdc, bm.Width - 8, bm.Height - 4, 8, 4, 8, 12
  TransBltA bm.hdc, bm.Width - 6, bm.Height \ 2 - 4, 4, 8, bm2.hdc, 4, 8, 4, 8, vbMagenta
 Else
  TransBltA bm.hdc, bm.Width - 6, bm.Height \ 2 - 4, 4, 8, bm2.hdc, 4, 0, 4, 8, vbMagenta
 End If
Else
 TransBltA bm.hdc, bm.Width - 6, bm.Height \ 2 - 4, 4, 8, bm2.hdc, 4, 16, 4, 8, vbMagenta
End If
DeleteObject h
h = CreateSolidBrush(&H9C9B91)
r.Top = bm.Height
r.Bottom = bm.Height
r.Left = 0
r.Right = 8 + Abs(strn - 1) * pw - nx
FrameRect bm.hdc, r, h
r.Left = 8 + strn * pw + ps2 + ps3 - nx
r.Right = bm.Width
FrameRect bm.hdc, r, h
DeleteObject h
UserControl_Paint
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
With PropBag
 PropBag.WriteProperty "PanelWidth", pw, 64
 PropBag.WriteProperty "HighlightBold", hb, False
 PropBag.WriteProperty "PanelTopSpace", ts, 2
 PropBag.WriteProperty "PanelSpace", ps, 1
 PropBag.WriteProperty "PanelOverlapLeft", ps3, 2
 PropBag.WriteProperty "PanelOverlapRight", ps2, 2
 PropBag.WriteProperty "FontSize", fnt.Size, 8
End With
End Sub

Public Property Get PanelWidth() As Long
PanelWidth = pw
End Property

Public Property Let PanelWidth(ByVal n As Long)
pw = n
Redraw
End Property

Public Property Get SelectedPanel() As Long
SelectedPanel = strn
End Property

Public Property Let SelectedPanel(ByVal n As Long)
If n >= 0 And n <= strc Then
 strn = n
 Redraw
End If
End Property

Public Property Get HighlightBold() As Boolean
HighlightBold = hb
End Property

Public Property Let HighlightBold(ByVal b As Boolean)
hb = b
Redraw
End Property

Public Property Get PanelTopSpace() As Long
PanelTopSpace = ts
End Property

Public Property Let PanelTopSpace(ByVal n As Long)
ts = n
Redraw
End Property

Public Property Get PanelSpace() As Long
PanelSpace = ps
End Property

Public Property Let PanelSpace(ByVal n As Long)
ps = n
Redraw
End Property

Public Property Get PanelOverlapRight() As Long
PanelOverlapRight = ps2
End Property

Public Property Let PanelOverlapRight(ByVal n As Long)
ps2 = n
Redraw
End Property

Public Property Get PanelOverlapLeft() As Long
PanelOverlapLeft = ps3
End Property

Public Property Let PanelOverlapLeft(ByVal n As Long)
ps3 = n
Redraw
End Property

Public Property Get FontSize() As Long
FontSize = fnt.Size
End Property

Public Property Let FontSize(ByVal n As Long)
fnt.Size = n
End Property
